home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 011-020 / amok12 / module / textwindow.mod < prev    next >
Text File  |  1993-11-04  |  13KB  |  564 lines
  1. (*---------------------------------------------------------------------------
  2.     :Program.    TextWindow.mod
  3.     :Author.     Bernd Preusing
  4.     :Address.    Gerhardstr. 16  D-2200 Elmshorn
  5.     :Phone.      04121/22486
  6.     :Shortcut.   [bep]
  7.     :Version.    1.1
  8.     :Date.       20-Apr-88
  9.     :Copyright.  PD
  10.     :Language.   Modula-II
  11.     :Translator. M2Amiga
  12.     :Imports.    none
  13.     :Cofiles.    HiTab.asm [bep] for INLINE HiKeyMap
  14.     :Contents.   TextIO on an own screen like m2emacs
  15.     :Remark.     
  16. ---------------------------------------------------------------------------*)
  17. IMPLEMENTATION MODULE TextWindow;
  18.  
  19. FROM SYSTEM IMPORT
  20.      ADR, ADDRESS, CAST, LONGSET, SHIFT, INLINE;
  21.  
  22. FROM Arts IMPORT
  23.      TermProcedure, Assert;
  24.  
  25. FROM Intuition IMPORT NewScreen, NewWindow, ScreenPtr, WindowPtr,
  26.      Screen, Window, WindowFlags, IDCMPFlags, IDCMPFlagSet,
  27.      WindowFlagSet, ScreenFlags, ScreenFlagSet, OpenScreen, IntuiMessagePtr,
  28.      OpenWindow, CloseScreen, CloseWindow, customScreen,
  29.      ClearMenuStrip, ModifyIDCMP, IntuiMessage,
  30.      SetMenuStrip, SetWindowTitles;
  31.  
  32. FROM Exec IMPORT UByte, MsgPort, MsgPortPtr, IOStdReq, IOStdReqPtr, write,
  33.      WaitPort, DoIO, GetMsg, RawDoFmt, ReplyMsg, OpenDevice,
  34.      CloseDevice, ExecBase, execBase, Message; 
  35.  
  36. FROM Graphics IMPORT ViewModes, ViewModeSet,
  37.      TextAttr, TextAttrPtr, FontStyleSet,
  38.      FontFlags, FontFlagSet, RastPortPtr;
  39.  
  40. FROM ExecSupport IMPORT
  41.      CreatePort, CreateStdIO, DeletePort, DeleteStdIO;
  42.  
  43. FROM Console IMPORT
  44.      consoleName, askDefaultKeyMap, setDefaultKeyMap;
  45.      (* setKeyMap geht merkwürdigerweise nicht. Ist ja auch klar, weil
  46.         Input via IDCMP geschieht und nich via console.device!!
  47.         (Dies war Selbstkritik.) *)
  48.  
  49. FROM ConUnit IMPORT
  50.      ConUnit, ConUnitPtr;
  51.  
  52. FROM KeyMap IMPORT
  53.      KeyMapTypes, KeyMapTypeSet, DeadPrefixBytes, DeadPrefixByteSet,
  54.      vanilla, BitTable, BitTablePtr, KeyInfo, Types, TypesPtr,
  55.      Info, InfoPtr, KeyMap, KeyMapPtr;
  56.  
  57. FROM Strings IMPORT Delete, Insert;
  58.  
  59. CONST
  60.     CSI = 233C;
  61.     myAll = IDCMPFlagSet{vanillaKey, activeWindow, inactiveWindow};
  62.  
  63.  
  64. VAR
  65.     oldKeyMap, newKeyMap: KeyMap;
  66.     eventEnabled: BOOLEAN;
  67.     AktiveProc: EventPROC;
  68.     ns: NewScreen;
  69.     myspt: ScreenPtr;
  70.     nw: NewWindow;
  71.     mywpt: WindowPtr;
  72.     proc: LONGCARD;
  73.     MyFont: TextAttr;
  74.     readPort, writePort: MsgPortPtr;
  75.     writeReq: IOStdReqPtr;
  76.     intP : IntuiMessagePtr;
  77.     intMsg: IntuiMessage;
  78.     cup: ConUnitPtr;
  79.     ftemp:ARRAY[0..127] OF CHAR;
  80.     itemp: ARRAY[0..7] OF CHAR;
  81. VAR x1,y1:INTEGER; (* wegen Reihenfolge nicht ändern! *)
  82.  
  83.  
  84. (* ------------------------------------------------------------ *)
  85. PROCEDURE Length(VAR s:ARRAY OF CHAR):INTEGER;
  86. TYPE CharPtr=POINTER TO CHAR;
  87. VAR l:INTEGER; a:CharPtr;
  88. BEGIN
  89.   a:=CAST(CharPtr,ADR(s));
  90.   l:=0;
  91.   WHILE a^#0C DO
  92.    INC(a);
  93.    INC(l)
  94.   END;
  95.   RETURN l
  96. END Length;
  97.  
  98. PROCEDURE Min(x,y:INTEGER):INTEGER;
  99. BEGIN
  100.  IF x<y THEN
  101.    RETURN x
  102.  ELSE
  103.    RETURN y
  104.  END
  105. END Min;
  106.  
  107. (*============================================================*)
  108. (* $E- *)
  109. PROCEDURE HiTab();  (* aus HiTab.asm *)
  110. BEGIN
  111. INLINE(
  112. (*0000*) 00000H,00000H,00000H,00000H,047F4H,0FF7FH,00000H,00000H,
  113. (*0010*) 02200H,00100H,00101H,00080H,08080H,00080H,00303H,00303H,
  114. (*0020*) 00101H,00101H,00101H,00101H,00101H,00505H,00000H,00001H,
  115. (*0030*) 08080H,08080H,08080H,08080H,08080H,08080H,08080H,08080H,
  116. (*0040*) 08080H,08080H,08080H,08080H,00000H,00128H,00000H,00008H,
  117. (*0050*) 00000H,09E09H,00000H,0000DH,00000H,00A0DH,00000H,09F1BH,
  118. (*0060*) 00000H,0007FH,00000H,00000H,00000H,00000H,00000H,00000H,
  119. (*0070*) 00000H,0002DH,00000H,00000H,09A12H,08A05H,09B03H,08B18H,
  120. (*0080*) 09D06H,08D04H,09C01H,08C13H,00000H,09080H,00000H,09181H,
  121. (*0090*) 00000H,09282H,00000H,09383H,00000H,09484H,00000H,09585H,
  122. (*00A0*) 00000H,09686H,00000H,09787H,00000H,09888H,00000H,09989H,
  123. (*00B0*) 01B1BH,07B5BH,01D1DH,07D5DH,00000H,0002FH,00000H,0002AH,
  124. (*00C0*) 00000H,0002BH,00000H,08F8EH,00000H,00000H,00000H,00000H,
  125. (*00D0*) 00000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,
  126. (*00E0*) 00000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,
  127. (*00F0*) 00000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,
  128. (*0100*) 00000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,
  129. (*0110*) 00000H,00000H,00000H,00000H,00000H,00000H,00000H,00000H,
  130. (*0120*) 00000H,00000H,00000H,00000H,00104H,000A0H,020B4H,0605EH,
  131. (*0130*) 07EA8H,0B45EH,0B4B4H,0B4B4H,06060H,05E60H,06060H,00000H)
  132. END HiTab;
  133.  
  134. PROCEDURE MakeKeyMap(VAR old,new:KeyMap);
  135. TYPE aarr=ARRAY[0..100] OF ADDRESS;
  136.      aarrPtr=POINTER TO aarr;
  137. VAR a:ADDRESS; aa:aarrPtr;
  138. BEGIN
  139.  a:=ADR(HiTab);
  140.  aa:=aarrPtr(a);
  141.  aa^[48H DIV 4]:=a+0128H; (* Ptr auf Space-Tabelle *)
  142. WITH new DO
  143.  loKeyMapTypes:=old.loKeyMapTypes;
  144.  loKeyMap:=old.loKeyMap;
  145.  loCapsable:=old.loCapsable;
  146.  loRepeatable:=old.loRepeatable;
  147.  hiKeyMapTypes:=a; INC(hiKeyMapTypes,0010H);
  148.  hiKeyMap:=a; INC(hiKeyMap,0048H);
  149.  hiCapsable:=a; INC(hiCapsable,0000H);
  150.  hiRepeatable:=a; INC(hiRepeatable,0008H);
  151. END;
  152. END MakeKeyMap;
  153. (*============================================================*)
  154.  
  155. PROCEDURE SetMap(VAR k:KeyMap);
  156. BEGIN
  157.  WITH writeReq^ DO
  158.   command:=setDefaultKeyMap;
  159.   data:=ADR(k);
  160.   length:=SIZE(k)
  161.  END;
  162.  DoIO(writeReq);
  163.  writeReq^.command:=write
  164. END SetMap;
  165.  
  166. PROCEDURE Printable(c:CHAR):BOOLEAN;
  167. BEGIN
  168.   RETURN ((c>=' ') AND (c<177C)) OR (c>=240C)
  169. END Printable;
  170.  
  171. PROCEDURE WriteS(s:ARRAY OF CHAR);
  172. BEGIN
  173.   WITH writeReq^ DO
  174.     length:=0FFFFFFFFH; (* -1 : Länge bis 0C *)
  175.     data:=ADR(s)
  176.   END;
  177.   DoIO(writeReq)
  178. END WriteS;
  179.  
  180. PROCEDURE WriteC(c: CHAR);
  181. BEGIN
  182.   WITH writeReq^ DO
  183.     length:=1;
  184.     data:=ADR(c)
  185.   END;
  186.   DoIO(writeReq)
  187. END WriteC;
  188.  
  189. PROCEDURE WriteCSI(s:ARRAY OF CHAR);
  190. BEGIN
  191.  WriteC(CSI);
  192.  WriteS(s);
  193. END WriteCSI;
  194.  
  195. PROCEDURE WriteLn();
  196. BEGIN
  197.   WriteC(12C)
  198. END WriteLn;
  199.  
  200. PROCEDURE WriteL(s:ARRAY OF CHAR);
  201. BEGIN
  202.   WriteS(s);
  203.   WriteC(12C)
  204. END WriteL;
  205.  
  206. PROCEDURE Format(s:ARRAY OF CHAR; dats:ADDRESS);
  207. BEGIN
  208.   RawDoFmt(ADR(s),dats,ADR(proc),ADR(ftemp));
  209.   WriteS(ftemp);
  210. END Format;
  211.  
  212. PROCEDURE FormatE(s:ARRAY OF CHAR; dats:ADDRESS);
  213. BEGIN
  214.   RawDoFmt(ADR(s),dats,ADR(proc),ADR(ftemp));
  215.   ftemp[0]:=CSI;
  216.   WriteS(ftemp);
  217. END FormatE;
  218.  
  219. PROCEDURE WriteInt(i:LONGINT;l:CARDINAL);
  220. BEGIN
  221.  itemp:='% ld';
  222.  IF l<10 THEN itemp[1]:=CHAR(l+30H) ELSE itemp[1]:='8' END;
  223.  Format(itemp,ADR(i))
  224. END WriteInt;
  225.  
  226. PROCEDURE WriteCard(i:LONGCARD;l:CARDINAL);
  227. BEGIN
  228.  itemp:='% ld';
  229.  IF l<10 THEN itemp[1]:=CHAR(l+30H) ELSE itemp[1]:='8' END;
  230.  Format(itemp,ADR(i))
  231. END WriteCard;
  232.  
  233. PROCEDURE WriteHex(i:LONGINT;l:CARDINAL);
  234. BEGIN
  235.  itemp:='%0 . lx';
  236.  IF l<10 THEN
  237.    itemp[2]:=CHAR(l+30H);
  238.    itemp[4]:=CHAR(l+30H)
  239.  ELSE
  240.    itemp[2]:='8';
  241.    itemp[4]:='8'
  242.  END;
  243.  Format(itemp,ADR(i))
  244. END WriteHex;
  245.  
  246.  
  247. PROCEDURE Sleep();
  248. BEGIN
  249.   WaitPort(readPort);
  250. END Sleep;
  251.  
  252. PROCEDURE MayGetC(VAR c:CHAR):BOOLEAN;
  253. VAR temp:BOOLEAN;
  254. BEGIN
  255.   intP:=GetMsg(readPort);
  256.   IF intP=NIL THEN
  257.     c:=0C;
  258.     temp:=FALSE
  259.   ELSE
  260.     intMsg:=intP^;
  261.     ReplyMsg(intP);
  262.     WITH intMsg DO
  263.     IF vanillaKey IN class THEN
  264.       c:=CHAR(code);
  265.       temp:=TRUE
  266.     ELSIF activeWindow IN class THEN
  267.       SetMap(newKeyMap);
  268.       temp:=FALSE
  269.     ELSIF inactiveWindow IN class THEN
  270.       SetMap(oldKeyMap);
  271.       temp:=FALSE
  272.     ELSE
  273.       IF eventEnabled THEN
  274.         execMessage.replyPort:=NIL; (* sicher ist sicher!! *)
  275.         AktiveProc(intMsg)
  276.       END;
  277.       temp:=FALSE
  278.     END;
  279.     END;
  280.   END;
  281.   RETURN temp
  282. END MayGetC;
  283.  
  284. PROCEDURE ReadC():CHAR;
  285. VAR temp:CHAR;
  286. BEGIN
  287.   REPEAT
  288.     Sleep();
  289.   UNTIL MayGetC(temp);
  290.   RETURN temp
  291. END ReadC;
  292.  
  293. PROCEDURE ReadLn(VAR s:ARRAY OF CHAR; VAR term:CHAR);
  294. VAR i,l,max,x,y,pos,oldlength,linelength:INTEGER;
  295.     ch:ARRAY [0..1] OF CHAR;
  296. BEGIN
  297.   ch[1]:=0C;
  298.   l:=Length(s); max:=Min(HIGH(s),cup^.xMax-cup^.xCP-1);
  299.   x:=cup^.xCP; y:=cup^.yCP;
  300.   linelength:=x+max+1;
  301.   oldlength:=cup^.xMax+1;
  302.   (* WriteCSI('42m');*) (* bg 2 *)
  303.   FormatE(' %du',ADR(linelength));
  304.   WriteS(s);
  305.   ClearEOL;
  306.   pos:=l;
  307.   LOOP
  308.    GotoXY(x+pos,y);
  309.    ch[0]:=ReadC();
  310.    IF Printable(ch[0]) THEN
  311.     IF l<max THEN
  312.       Insert(s,pos,ch) ; INC(l); WriteCSI('@'); WriteC(ch[0]); INC(pos)
  313.     END
  314.    ELSE
  315.     CASE ch[0] OF
  316.      | cLeft: IF pos>0 THEN DEC(pos) END;
  317.      | cRight: IF pos<l THEN INC(pos) END;
  318.      | scLeft: pos:=0;
  319.      | scRight: pos:=l;
  320.      | 33C:  s:=''; GotoXY(x,y); ClearEOL;
  321.         pos:=0; l:=0;
  322.      | kDel: IF pos<l THEN Delete(s,pos,1); WriteCSI('P'); DEC(l) END;
  323.      | 10C:  IF pos>0 THEN DEC(pos); Delete(s,pos,1); GotoXY(x+pos,y);
  324.                WriteCSI('P'); DEC(l) END;
  325.      | 15C,cDown,cUp: term:=ch[0];
  326.               EXIT;
  327.      | ELSE (* nichts *)
  328.     END; (* case *)
  329.    END; (* if printable *)
  330.   END; (* LOOP *)
  331.   (* WriteCSI('0m');*)
  332.   FormatE(' %du',ADR(oldlength));
  333.   WriteLn
  334. END ReadLn;
  335.  
  336. (* ------------------------------------------------------------ *)
  337.  
  338.  
  339. PROCEDURE GotoXY(x,y:INTEGER);
  340. BEGIN
  341.  (*x1:=x+1; y1:=y+1;*)
  342.  INC(x); INC(y);
  343.  FormatE(' %d;%dH',ADR(y))
  344. END GotoXY;
  345.  
  346. PROCEDURE CurOn();
  347. BEGIN
  348.  WriteCSI(' p')
  349. END CurOn;
  350.  
  351. PROCEDURE CurOff();
  352. BEGIN
  353.  WriteCSI('0 p')
  354. END CurOff;
  355.  
  356. PROCEDURE WrapOn();
  357. BEGIN
  358.  WriteCSI('?7h')
  359. END WrapOn;
  360.  
  361. PROCEDURE WrapOff();
  362. BEGIN
  363.  WriteCSI('?7l')
  364. END WrapOff;
  365.  
  366. PROCEDURE ScrollOn();
  367. BEGIN
  368.  WriteCSI('>1h')
  369. END ScrollOn;
  370.  
  371. PROCEDURE ScrollOff();
  372. BEGIN
  373.  WriteCSI('>1l')
  374. END ScrollOff;
  375.  
  376. PROCEDURE DelLine();
  377. BEGIN
  378.  WriteCSI('M')
  379. END DelLine;
  380.  
  381. PROCEDURE InsLine();
  382. BEGIN
  383.  WriteCSI('L')
  384. END InsLine;
  385.  
  386. PROCEDURE CurX():INTEGER;
  387. BEGIN
  388.  RETURN cup^.xCP
  389. END CurX;
  390.  
  391. PROCEDURE CurY():INTEGER;
  392. BEGIN
  393.   RETURN cup^.yCP
  394. END CurY;
  395.  
  396. PROCEDURE ClearWindow();
  397. BEGIN
  398.  WriteC(14C);
  399. END ClearWindow;
  400.  
  401. PROCEDURE CurMax(VAR x,y:INTEGER);
  402. BEGIN
  403.  WITH cup^ DO
  404.    x:=xMax;
  405.    y:=yMax
  406.  END;
  407. END CurMax;
  408.  
  409. PROCEDURE Title(VAR s:ARRAY OF CHAR);
  410. BEGIN
  411.  SetWindowTitles(mywpt,-1,ADR(s))
  412. END Title;
  413.  
  414. PROCEDURE ClearEOL();
  415. BEGIN
  416.   WriteCSI('K')
  417. END ClearEOL;
  418.  
  419. PROCEDURE ClearEOS();
  420. BEGIN
  421.   WriteCSI('J')
  422. END ClearEOS;
  423.  
  424. PROCEDURE Colour(fg,bg:Colours;style:Style);
  425. VAR b,f,s:INTEGER;
  426. BEGIN
  427.  b:=bg+40; f:=fg+30; s:=INTEGER(style);
  428.  FormatE(' %d;%d;%dm',ADR(s))
  429. END Colour;
  430.  
  431. PROCEDURE NormColours();
  432. BEGIN
  433.  WriteCSI('0m') (* setzt auch fg1, bg0 *)
  434. END NormColours;
  435.  
  436. PROCEDURE EventProcedure(EProc:EventPROC;
  437.              Flags:IDCMPFlagSet;
  438.              menuPtr:ADDRESS);
  439. BEGIN
  440.   ClearMenuStrip(mywpt);
  441.   IF EProc#NIL THEN
  442.     eventEnabled:=TRUE;
  443.     AktiveProc:=EProc;
  444.     IF menuPtr#NIL THEN
  445.       ModifyIDCMP(mywpt,Flags+myAll+IDCMPFlagSet{menuPick});
  446.       Assert(SetMenuStrip(mywpt,menuPtr),
  447.         ADR('TextWindow: Menü nicht anzubringen'));
  448.     ELSE
  449.       ModifyIDCMP(mywpt,Flags+myAll);
  450.     END
  451.   ELSE
  452.     eventEnabled:=FALSE;
  453.     ModifyIDCMP(mywpt,myAll)
  454.   END
  455. END EventProcedure;
  456.  
  457. PROCEDURE GetWindow():WindowPtr;
  458. BEGIN
  459.   RETURN mywpt
  460. END GetWindow;
  461.  
  462. PROCEDURE GetRastPort():RastPortPtr;
  463. BEGIN
  464.   RETURN mywpt^.rPort
  465. END GetRastPort;
  466.  
  467.  
  468. PROCEDURE Init();    
  469. BEGIN
  470.   eventEnabled:=FALSE;
  471.   proc:=16C04E75H; (* move.b d0,(a3)+  RTS *)
  472.   mywpt:=NIL;
  473.   myspt:=NIL;
  474.   writePort:=NIL;
  475.   writeReq:=NIL;
  476.   WITH MyFont DO
  477.     name:=ADR("topaz.font");
  478.     ySize:=8;
  479.     style:=FontStyleSet{};
  480.     flags:=FontFlagSet{romFont}
  481.   END;
  482.   
  483.   WITH ns DO
  484.     leftEdge:=0; topEdge:=0;
  485.     width:=640;
  486.     IF execBase^.vBlankFrequency<55 THEN
  487.       height:=260 (* PAL *)
  488.     ELSE
  489.       height:=204 (* NTSC *)
  490.     END;
  491.     depth:=2; detailPen:=0; blockPen:=1;
  492.     viewModes:=ViewModeSet{hires}; type:=customScreen;
  493.     font:=ADR(MyFont);
  494.     defaultTitle:=ADR("TextScreen 1.1");
  495.     gadgets:=NIL; customBitMap:=NIL;
  496.   END;
  497.   myspt:=OpenScreen(ns);
  498.   Assert(myspt#NIL,ADR("Screen nicht zu öffnen!"));
  499.  
  500.   WITH nw DO
  501.     leftEdge:=00; topEdge:=12;
  502.     width:=640; height:=myspt^.height-12;
  503.     detailPen:=0; blockPen:=1;
  504.     idcmpFlags:=myAll;
  505.     flags:=WindowFlagSet{simpleRefresh, noCareRefresh, 
  506.                 activate,backDrop,borderless};
  507.     firstGadget:=NIL; checkMark:=NIL;
  508.     title:=NIL; screen:=myspt; bitMap:=NIL;
  509.     minWidth:=width; minHeight:=height;
  510.     maxWidth:=width; maxHeight:=height;
  511.     type:=customScreen;
  512.   END;
  513.   mywpt:=OpenWindow(nw);
  514.   Assert(mywpt#NIL,ADR("Window nicht zu öffnen!"));
  515.   readPort:=mywpt^.userPort;
  516.   writePort:=CreatePort(ADR("myWritePort"),0);
  517.   Assert(writePort#NIL,ADR("writePort nicht zu öffnen!"));
  518.   writeReq:=CreateStdIO(writePort);
  519.   Assert(writeReq#NIL,ADR("IOwriteReq nicht zu öffnen!"));
  520.   writeReq^.data:=mywpt;
  521.   writeReq^.length:=SIZE(mywpt^);
  522.   writeReq^.device:=NIL;
  523.   OpenDevice(ADR("console.device"),0,writeReq,LONGSET{});
  524.   cup:=CAST(ConUnitPtr,writeReq^.unit);
  525.   Assert(writeReq^.device#NIL,ADR("console.device openErr"));
  526.   WITH writeReq^ DO
  527.     command:=askDefaultKeyMap;
  528.     data:=ADR(oldKeyMap);
  529.     length:=SIZE(oldKeyMap)
  530.   END;
  531.   DoIO(writeReq);
  532.   Assert(writeReq^.error=0,ADR("askDefaultKeyMap err"));
  533.   MakeKeyMap(oldKeyMap,newKeyMap);
  534.   SetMap(newKeyMap); (* setzt auch .command auf write *)
  535. END Init;
  536.  
  537. PROCEDURE Exit();
  538. BEGIN
  539.   IF writeReq#NIL THEN
  540.     SetMap(oldKeyMap);
  541.     CloseDevice(writeReq);
  542.     DeleteStdIO(writeReq);
  543.     writeReq:=NIL
  544.   END;
  545.   IF writePort#NIL THEN
  546.     DeletePort(writePort);
  547.     writePort:=NIL
  548.   END;
  549.   IF mywpt#NIL THEN
  550.     ClearMenuStrip(mywpt);
  551.     CloseWindow(mywpt);
  552.     mywpt:=NIL
  553.   END;
  554.   IF myspt#NIL THEN
  555.     CloseScreen(myspt);
  556.     myspt:=NIL
  557.   END;
  558. END Exit;
  559.  
  560. BEGIN
  561.    TermProcedure(Exit);
  562.    Init;
  563. END TextWindow.mod
  564.